
-[private] uterm_t *get_single_word_binding
	(parser_t *p, pflist_t *bindings,char *name)
{
	utermlist_t *L;
	L= get_macro_arg(p,bindings,name);
	return L->head.next->data;
}

-[private] utermlist_t *get_macro_arg
	(parser_t* p, pflist_t *args, char *name)
{
	utermlist_t *R;
	linenumber_t lineno= { "[builtin-getmacroarg]", 1};
	pflist_t *ctx;
	ctx= parser_top_context(p);
	costack_push(p->costack, args);
	R= expand_macroarg(p, &lineno, name);
	while (parser_top_context(p)!=ctx)
		costack_pop(p->costack);
	return R;
}

-[public] variable_t *variable_new(char *name,type_t *vt)
{
	variable_t *V;
	-[ allocate object V ]
	V->name= name;
	V->type= vt;
	V->value= 0;
	return V;
}



-[public] parser_t *parser_new
	(utermlist_t *body,parser_t *parent)
{
	parser_t *P;
	-[ allocate object P ]
	P->parent= parent;
	P->astack= astack_new();
	P->ostack= ostack_new();
	P->expect_term= 1;
	P->body= body;
	P->vars= varlist_new();
	P->costack= costack_new();
	costack_push(P->costack, pflist_new());
	return P;
}

-[public] pfunc_t *pfunc_new
	(enum pfunc_kind kind, char *name,
	linenumber_t *linenumber, void *data)
{
	pfunc_t *C;
	-[ allocate object C ]
	C->kind= kind;
	C->name= name;
	C->linenumber= linenumber;
	switch(kind) {
	case pfunc_builtin: C->d.builtin= data; break;
	case pfunc_user: C->d.user= data; break;
	}
	return C;
}

-[public] void print_error_exit(char *fmt, ...) {
	va_list ap;
	if (!currentfunc_isempty(currentfunc)) 
		fprintf(stderr,"in function '%s' ", 
			currentfunc_pop(currentfunc)); 
	while(!callhistory_isempty(callhistory)) {
		linenumber_t* L;
		L= callhistory_pop(callhistory);
		if (!L) break;
		fprintf(stderr,"%s:%d\n", L->file,L->line);
	}
	va_start(ap,fmt);
	vfprintf(stderr,fmt, ap);
	va_end(ap);
	fflush(0);
	*(int*)0 = 0;
}

-[private] void pflist_append_destructive(pflist_t *to,pflist_t *from)
{
	while(!pflist_isempty(from)) {
		pfunc_t *F;
		F=pflist_destroy(from);
		pflist_append(to, F);
	}
	free(from);
}

-[closure pushintv, begin ]
	-[arg success : int* ]
	-[arg parser :parser_t *]
	-[arg value : int ]
	-[ closure is private ]
	-[ function is private ]
-[end] {
	operand_t A;
	*success= 1;
	A.kind= operand_intconst;
	A.d.intv= value;
	astack_push(parser->astack,A);
}


-[public] void dump_parsers(parser_t *P) {
	while(P) {
		printf("PARSER-------\n");
		printf("  BODY:\n");
		dump_termlist(P->body);
		printf("\n---\n");
		if (!astack_isempty(P->astack)) {
			printf("  ASTACK:\n");
			dump_astack(P->astack);
			printf("---\n");
		}
		if (!ostack_isempty(P->ostack)) {
			printf("  OSTACK:\n");
			dump_ostack(P->ostack);
			printf("---\n");
		}
		if (!costack_isempty(P->costack)) {
			printf("CONTEXT STACK:\n");
			int i;
			for(i=P->costack->nelts-1;i>=0;i--) {
				dump_context(P->costack->elts[i]);
			}
			printf("ENDCONTEXTSTACK\n");
		} else printf("EMPTY CONTEXT STACK\n");
		if (varlist_isempty(P->vars)) {
			printf("NO VARIABLES\n");
		} else {
			printf("VARIABLES\n");
			-[ list>for Z ∈ *P->vars, begin ]
				printf("\tVAR %s\n", Z->name);
			-[ end ]
		}
		P= P->parent;
	}
	printf("GLOBAL CONTEXT-----\n");
	dump_context(global_context);
	printf("USER GLOBAL CONTEXT-----\n");
	dump_context(uglobal_context);
}

-[public] void dump_astack(astack_t *S) {
	int i;
	for(i=S->nelts-1;i>=0;i--) {
		operand_t A= S->elts[i];
		switch(A.kind) {
		case operand_varref:
			printf("   var %s ",A.d.varref->name);
			dump_type(A.d.varref->type);
			break;
		case operand_intconst:
			printf("   int %d",A.d.intv);
			break;
		case operand_utermlist:
			printf("  expr " );
			dump_termlist(A.d.termlist);
			printf("\n");
			break;
		case operand_void:
			printf(" void_value ");
			break;
		case operand_type:
			printf(" type ");
			dump_type(A.d.type);
			printf("\n");
			break;
		}
		if (A.code)  {
			printf("{"); dump_termlist(A.code); printf("}");
		}
		printf("\n");
	}
}

-[public] void dump_ostack(ostack_t *S) {
	int i;
	for(i=S->nelts-1;i>=0;i--) {
		operator_t OP= S->elts[i];
		printf("   OP %d %d %s\n", OP.prec,OP.rassoc,
			OP.reduction);
	}
}

-[private] void get_n_args(parser_t *p, int n, utermlist_t **args)
{
	int i;
	for(i=0;i<n;i++) {
		uterm_t *T;
		T= utermlist_destroy(p->body);
		if (!T || T->kind!=ut_cu_bulk)
			print_error_exit("arguments to simple "
			"functions must be in curly braces\n" );
		args[i]= T->body;
	}
}


-[closure simple_builtin, begin]
	-[ closure is private ]
	-[ function is private] 
	-[ arg parser : parser_t* ]
	-[ arg success : int* ]
	-[ arg nargs : int ]
	-[ arg func : void* ]
-[end]
{
	int i;
#define SIMPLE_MAX 5
	utermlist_t *args[SIMPLE_MAX];
	*success= 1;
	for(i=0;i<nargs;i++) {
		uterm_t *T;
		T= utermlist_destroy(parser->body);
		if (!T || T->kind!=ut_cu_bulk)
			print_error_exit("arguments to simple "
			"functions must be in curly braces\n" );
		args[i]= T->body;
	}
	switch(nargs) {
	-[ simple builtin 5 ]
	-[ simple builtin 4 ]
	-[ simple builtin 3 ]
	-[ simple builtin 2 ]
	-[ simple builtin 1 ]
	}
}



=[ simple builtin $N ]
	case $N : 
		((void (*)(parser_t *parser
	![perl] for($i=1;$i<=$N;$i++) { printf( ",utermlist_t *") } ![end]
		)) func) (parser 
	![perl] for($i=1;$i<=$N;$i++)
	{ printf( ",args[%d]", $i-1); } ![end]
		);
		break;
=[]

-[closure compile_and_run_assembly, begin ]
	-[arg success : int* ]
	-[arg parser :parser_t *]
	-[arg compiler : closure_t* ]
	-[ closure is private ]
	-[ function is private ]
-[end] {
	codelist_t *C;
	int dummy;
	*success= 1;
	C= codelist_new();
	closure_set(compiler, "codelist", C);
	closure_set(compiler, "parser", parser);
	closure_set(compiler, "success", &dummy);
	closure_call(compiler);
	interp_run(C);
}

-[public] pflist_t* parser_top_context(parser_t *p) {
	return p->costack->elts[p->costack->nelts-1];
}


-[public] void dump_context(pflist_t *C) {
	printf("\tCONTEXT\n");
	-[ list>for Z ∈ *C, begin ]
		printf("\t\tCFUNC %s %s\n",
			Z->name,
		Z->kind==pfunc_builtin ?
			"builtin" : "user");
	-[ end ]
}

-[public] void parser_prepend_call
	(parser_t *p,char *fname)
{
	static linenumber_t L= { "[builtin-prependcall]", 1 };
	utermlist_prepend(p->body,
		uterm_simple(ut_word, strdup(fname), &L));
}

-[public] void parser_prepend_assembly_call
	(parser_t *p,char *fname, ...)
{
	static linenumber_t L= { "[builtin-prependacall]", 1 };
	utermlist_t *T;
	va_list ap;
	T= utermlist_new();
	utermlist_append(T,
		uterm_simple(ut_word, strdup(fname), &L));
	va_start(ap,fname);
	while(1) {
		utermlist_t *V;
		V= va_arg(ap, utermlist_t*);
		if (!V) break;
		utermlist_append(T,  uterm_cu_bulk(V, &L));
	}
	va_end(ap);
	utermlist_prepend_destructive(T, p->body);
}

